Overview first, zoom and filter, then details on demand
Seeing Theory: A visual introduction to probability and statistics
America’s Public Bible: Biblical Quotations in U.S. Newspapers
ggplot2 and ggvishtmlwidgetsplotlyplotly API librariesplot_ly() objectsplot_ly()
qplot()add_() functionslibrary(plotly)
plot_ly(data = mpg, x = ~displ, y = ~hwy,
type = "scatter")# alternative form
plot_ly(data = mpg, x = ~displ, y = ~hwy) %>%
add_markers()plot_ly(data = mpg, x = ~displ, y = ~hwy, color = ~class,
type = "scatter")plot_ly(data = mpg, x = ~displ, y = ~hwy, color = ~class,
type = "scatter",
colors = "Accent")subplot(
plot_ly(mpg, x = ~cty, y = ~hwy, name = "default",
type = "scatter"),
plot_ly(mpg, x = ~cty, y = ~hwy) %>%
add_markers(alpha = 0.2, name = "alpha"),
plot_ly(mpg, x = ~cty, y = ~hwy) %>%
add_markers(symbol = I(1), name = "hollow")
)plot_ly(mtcars, x = ~disp, color = I("black")) %>%
add_markers(y = ~mpg, text = rownames(mtcars), showlegend = FALSE) %>%
add_lines(y = ~fitted(loess(mpg ~ disp)),
line = list(color = '#07A4B5'),
name = "Loess Smoother", showlegend = TRUE)plot_ly(diamonds, x = ~price,
type = "histogram")p1 <- plot_ly(diamonds, x = ~cut) %>%
add_histogram()
p2 <- diamonds %>%
dplyr::count(cut) %>%
plot_ly(x = ~cut, y = ~n) %>%
add_bars()
subplot(p1, p2) %>%
hide_legend()ggplotly()p <- ggplot(mpg, aes(displ, hwy)) +
geom_point()
ggplotly(p)ggplotly()p <- ggplot(mpg, aes(displ, hwy)) +
geom_point(aes(color = class))
ggplotly(p)ggplotly()ggplotly(p +
geom_smooth())ggplotly()p <- ggplot(mpg, aes(displ, hwy)) +
geom_point(aes(color = class,
text = str_c(manufacturer, model, sep = " "))) +
geom_smooth()
ggplotly(p)ggplotly() objectsstr(plotly_build(p), max.level = 2)## List of 8
## $ x :List of 9
## ..$ data :List of 9
## ..$ layout :List of 10
## ..$ config :List of 3
## ..$ source : chr "A"
## ..$ attrs :List of 2
## ..$ cur_data : chr "157e14d75cf07"
## ..$ visdat :List of 2
## ..$ highlight:List of 6
## ..$ base_url : chr "https://plot.ly"
## ..- attr(*, "TOJSON_FUNC")=function (x, ...)
## $ width : NULL
## $ height : NULL
## $ sizingPolicy :List of 6
## ..$ defaultWidth : chr "100%"
## ..$ defaultHeight: num 400
## ..$ padding : NULL
## ..$ viewer :List of 6
## ..$ browser :List of 4
## ..$ knitr :List of 3
## $ dependencies :List of 4
## ..$ :List of 10
## .. ..- attr(*, "class")= chr "html_dependency"
## ..$ :List of 10
## .. ..- attr(*, "class")= chr "html_dependency"
## ..$ :List of 10
## .. ..- attr(*, "class")= chr "html_dependency"
## ..$ :List of 10
## .. ..- attr(*, "class")= chr "html_dependency"
## $ elementId : chr "157e126d9da19"
## $ preRenderHook:function (p, registerFrames = TRUE)
## $ jsHooks :List of 1
## ..$ render:List of 1
## - attr(*, "class")= chr [1:2] "plotly" "htmlwidget"
## - attr(*, "package")= chr "plotly"
ggplotly() objectslibrary(tidyverse)
library(stringr)
library(plotly)
library(rJava)
library(XLConnect)
options(digits = 3)
set.seed(1234)
theme_set(theme_minimal())
# function to convert outputs to tidy data frame
tidy_outputs <- function(outputs){
outputs %>%
as_tibble %>%
gather(year, value, -Revenue.effect, convert = TRUE) %>%
mutate(year = parse_number(year),
Revenue.effect = factor(Revenue.effect,
levels = c("User Model",
"The Joint Committee on Taxation",
"The Lindsey Group")))
}
# load model workbook and default inputs and outputs
# sorry i cannot share this file with you - it's proprietary
model <- loadWorkbook("data/OTCModelFeb2017rev5-Widget.xlsx")
model_inputs <- readWorksheet(model, "R-in")
# create color palette for graph
cbbpal <- c('#1b9e77', '#d95f02', '#7570b3')
# generate data
model_data <- tidy_outputs(readWorksheet(model, "R-out"))
model_data
# generate basic graph
g <- model_data %>%
rename(Year = year, `Revenue effect` = value, `Model` = Revenue.effect) %>%
ggplot(aes(Year, `Revenue effect`, color = Model)) +
geom_line(size = 1.5) +
scale_color_manual(values = cbbpal) +
guides(color = guide_legend(nrow = 1)) +
labs(x = "Year",
y = "Millions (USD)",
color = NULL) +
theme_minimal(base_size = 14)
# static version
g
# plotly version
p <- plotly_build(g)
p
# view legend components
p$x$layout$legend
# fix legend position
p$x$layout$legend$x <- .5
p$x$layout$legend$y <- -.3
p$x$layout$legend$xanchor <- "center"
p$x$layout$legend$yanchor <- "top"
p$x$layout$legend$orientation <- "h"
p
# view structure
p$x$data[[1]]
# need to change the $text element - written in html
p$x$data[[1]]$text <- str_replace_all(p$x$data[[1]]$text,
pattern = "`Revenue effect`", "Revenue effect")
p$x$data[[2]]$text <- str_replace_all(p$x$data[[2]]$text,
pattern = "`Revenue effect`", "Revenue effect")
p$x$data[[3]]$text <- str_replace_all(p$x$data[[3]]$text,
pattern = "`Revenue effect`", "Revenue effect")
plibrary(shiny)
ui <- fluidPage()
server <- function(input, output) {}
shinyApp(ui = ui, server = server)Important: Do not place any code after shinyApp()
Save file as app.R \(\rightarrow\) “Run” button turns to “Run App”
Good for creating Shiny apps quickly, all code in one file
Save UI as ui.R and server as server.R in same directory
Good for complex Shiny apps, separates view vs logic
If using this method, do not include a call to shinyApp(...)
File > New File > Shiny Web App…
Generates the template for you
Press “Esc” or click the Stop icon
fluidPage()library(shiny)
ui <- fluidPage("Hello CFSS")
server <- function(input, output) {}
shinyApp(ui = ui, server = server)fluidPage()fluidPage(
h1("My Shiny app"),
"Hello CFSS"
)fluidPage()h1() = header1br() = line breakstrong() = bold texttags object
h1 = tags$h1(), br = tags$br()tagsfluidPage()fluidPage(
h1("My Shiny app"),
h3("Subtitle"),
"Hello",
"CFSS",
br(),
strong("bold text")
)sidebarLayout()sidebarLayout()fluidPage(
titlePanel("My Shiny app"),
sidebarLayout(
sidebarPanel(
"This is a side panel"
),
mainPanel(
"And this is the main stuff"
)
)
)sidebarLayout()library(shiny)
ui <- fluidPage(
sliderInput(
"num", "Choose a number",
min = 0, max = 100,
value = 20)
)
server <- function(input, output) {}
shinyApp(ui = ui, server = server)sliderInput("num", "Choose a number",
min = 0, max = 100, value = 20)print(sliderInput("num", "Choose a number",
min = 0, max = 100, value = 20))## <div class="form-group shiny-input-container">
## <label class="control-label" for="num">Choose a number</label>
## <input class="js-range-slider" id="num" data-min="0" data-max="100" data-from="20" data-step="1" data-grid="true" data-grid-num="10" data-grid-snap="false" data-prettify-separator="," data-prettify-enabled="true" data-keyboard="true" data-keyboard-step="1" data-data-type="number"/>
## </div>
sliderInput("num",
"Choose a number",
min = 0,
max = 0,
value = 20)| Function | Outputs |
|---|---|
plotOutput() |
plot |
tableOutput() |
table |
uiOutput() |
Shiny UI element |
textOutput() |
text |
sliderInput("num",
"Choose a number",
min = 0,
max = 0,
value = 20)library(shiny)
ui <- fluidPage(
sliderInput("num", "Choose a number",
0, 100, 20),
plotOutput("myplot")
)
server <- function(input, output) {}
shinyApp(ui = ui, server = server)fluidPage()*Input() functions*Output() functionsserver to assemble inputs into outputsRemember to:
server <- function(input, output) {
output$myplot <- renderPlot({
plot(rnorm(input$num))
})
}output$render*()Output() \(\rightarrow\) render*()| Output function | Render function |
|---|---|
plotOutput() |
renderPlot({}) |
tableOutput() |
renderTable({}) |
uiOutput() |
renderUI({}) |
textOutput() |
renderText({}) |
render*() functions build reactive output to display in UIrenderPlot({
plot(rnorm(100))
})server <- function(input, output) {
output$myplot <- renderPlot({
plot(rnorm(input$num))
# in UI:sliderInput("num", ...)
})
}output$render*()input$x changes, anything that relies on x is re-evaluatedContrast with regular R:
x <- 5
y <- x + 1
x <- 10
# y is still 6input$num is a reactive value
output$myplot <- renderPlot({
plot(rnorm(input$num))
})output$myplot depends on input$num
input$num changes \(\rightarrow\) output$myplot reactsAll inputs are automatically reactive, so if you use any input inside a render* function, the output will re-render any time input changes
render* function is a reactive contextreactive({...}) to assign a reactive variableobserve({...}) to access a reactive variableserver <- function(input, output) {
x <- input$num + 1
}
# errorserver <- function(input, output) {
x <- reactive({
input$num + 1
})
}
# OKserver <- function(input, output) {
print(input$num)
}
# errorserver <- function(input, output) {
observe({
print(input$num)
})
}
# OKlibrary(shiny)
ui <- fluidPage(
sliderInput("num", "Choose a number",
0, 100, 20),
plotOutput("myplot")
)
server <- function(input, output) {
output$myplot <- renderPlot({
plot(seq(input$num))
})
x <- reactive({
input$num + 1
})
observe({
print(x())
})
}
shinyApp(ui = ui, server = server)uiOutput()library(shiny)
ui <- fluidPage(
numericInput("num", "Maximum slider value", 5),
uiOutput("slider")
)
server <- function(input, output) {
output$slider <- renderUI({
sliderInput("slider", "Slider", min = 0,
max = input$num, value = 0)
})
}
shinyApp(ui = ui, server = server)---
output: html_document
runtime: shiny
---
```{r echo=FALSE, eval = TRUE}
sliderInput("num", "Choose a number",
0, 100, 20)
renderPlot({
plot(seq(input$num))
})
```
conditionalPanel() to conditionally show UI elementslibrary(shiny)
ui <- fluidPage(
numericInput("num", "Number", 5, 1, 10),
conditionalPanel(
"input.num >=5",
"Hello!"
)
)
server <- function(input, output) {}
shinyApp(ui = ui, server = server)navbarPage() or tabsetPanel() to have multiple tabs in the UIlibrary(shiny)
ui <- fluidPage(
tabsetPanel(
tabPanel("Tab 1", "Hello"),
tabPanel("Tab 2", "there!")
)
)
server <- function(input, output) {}
shinyApp(ui = ui, server = server)tableOutput() + renderTable()DT::dataTableOutput() + DT::renderDataTable()update*Input() functions to update input values programmaticallylibrary(shiny)
ui <- fluidPage(
sliderInput("slider", "Move me", value = 5, 1, 10),
numericInput("num", "Number", value = 5, 1, 10)
)
server <- function(input, output, session) {
observe({
updateNumericInput(session, "num", value = input$slider)
})
}
shinyApp(ui = ui, server = server)server()
library(shiny)
ui <- fluidPage(
tags$head(tags$script("alert('Hello!');")),
tags$head(tags$style("body{ color: blue; }")),
"Hello"
)
server <- function(input, output) {
}
shinyApp(ui = ui, server = server)highcharterflexdashboard and information dashboards